home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / mips / insts.lisp < prev    next >
Encoding:
Text File  |  1992-04-03  |  32.6 KB  |  1,102 lines
  1. ;;; -*- Package: MIPS -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: insts.lisp,v 1.39 92/03/06 10:46:02 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Description of the MIPS architecture.
  15. ;;;
  16. ;;; Written by William Lott
  17. ;;;
  18.  
  19. (in-package "MIPS")
  20. (use-package "ASSEM")
  21. (use-package "EXT")
  22.  
  23. (disassem:set-disassem-params
  24.  :instruction-alignment 32
  25.  :storage-class-sets '((register any-reg descriptor-reg base-char-reg
  26.                  sap-reg signed-reg unsigned-reg
  27.                  non-descriptor-reg interior-reg)
  28.                (float-reg single-reg double-reg)
  29.                (control-stack control-stack)
  30.                (number-stack signed-stack unsigned-stack
  31.                      base-char-stack sap-stack
  32.                      single-stack double-stack))
  33.  )
  34.  
  35.  
  36. ;;;; Resources.
  37.  
  38. (define-resources high low memory float-status)
  39.  
  40.  
  41. ;;;; Special argument types and fixups.
  42.  
  43. (defun register-p (object)
  44.   (and (tn-p object)
  45.        (let* ((sc (tn-sc object))
  46.           (sc-name (sc-name sc))
  47.           (sb (sc-sb sc))
  48.           (sb-name (sb-name sb)))
  49.      (or (eq sc-name 'zero)
  50.          (eq sc-name 'null)
  51.          (eq sb-name 'registers)))))
  52.  
  53. (defun tn-register-number (tn)
  54.   (sc-case tn
  55.     (zero zero-offset)
  56.     (null null-offset)
  57.     (t (tn-offset tn))))
  58.  
  59. (defconstant reg-symbols
  60.   (map 'vector
  61.        #'(lambda (name)
  62.        (cond ((null name) nil)
  63.          (t (make-symbol (concatenate 'string "$" name)))))
  64.        *register-names*))
  65.  
  66. (define-argument-type register
  67.   :type '(satisfies register-p)
  68.   :function tn-register-number
  69.   :disassem-printer #'(lambda (value stream dstate)
  70.             (declare (stream stream) (fixnum value))
  71.             (let ((regname (aref reg-symbols value)))
  72.               (princ regname stream)
  73.               (disassem:maybe-note-associated-storage-ref
  74.                value
  75.                'register
  76.                regname
  77.                dstate)))
  78.   )
  79.  
  80. (defun fp-reg-p (object)
  81.   (and (tn-p object)
  82.        (eq (sb-name (sc-sb (tn-sc object)))
  83.        'float-registers)))
  84.  
  85. (defconstant float-reg-symbols
  86.   (coerce 
  87.    (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
  88.    'vector))
  89.  
  90. (define-argument-type fp-reg
  91.   :type '(satisfies fp-reg-p)
  92.   :function tn-offset
  93.   :disassem-printer #'(lambda (value stream dstate)
  94.             (declare (stream stream) (fixnum value))
  95.             (let ((regname (aref float-reg-symbols value)))
  96.               (princ regname stream)
  97.               (disassem:maybe-note-associated-storage-ref
  98.                value
  99.                'float-reg
  100.                regname
  101.                dstate)))
  102.   )
  103.  
  104. (define-argument-type odd-fp-reg
  105.   :type '(satisfies fp-reg-p)
  106.   :function (lambda (tn)
  107.           (1+ (tn-offset tn))))
  108.  
  109. (define-argument-type control-register
  110.   :type '(unsigned-byte 5)
  111.   :function identity
  112.   :disassem-printer "{CR:#x~X}")
  113.  
  114. (defun label-offset (label)
  115.   (1- (ash (- (label-position label) *current-position*) -2)))
  116.  
  117. (define-argument-type relative-label
  118.   :type 'label
  119.   :function label-offset
  120.   :sign-extend t
  121.   :disassem-use-label #'(lambda (value dstate)
  122.               (declare (type disassem:disassem-state dstate))
  123.               (+ (ash (1+ value) 2)
  124.                  (disassem:dstate-curpos dstate))))
  125.  
  126. (defun float-format-value (format)
  127.   (ecase format
  128.     ((:s :single) 0)
  129.     ((:d :double) 1)
  130.     ((:w :word) 4)))
  131.  
  132. (define-argument-type float-format
  133.   :type '(member :s :single :d :double :w :word)
  134.   :function float-format-value
  135.   :disassem-printer #'(lambda (value stream dstate)
  136.             (declare (ignore dstate)
  137.                  (stream stream)
  138.                  (fixnum value))
  139.             (princ (case value
  140.                  (0 's)
  141.                  (1 'd)
  142.                  (4 'w)
  143.                  (t '?))
  144.                    stream)))
  145.             
  146.  
  147. (defconstant compare-kinds
  148.   '(:f :un :eq :ueq :olt :ult :ole :ule :sf :ngle :seq :ngl :lt :nge :le :ngt))
  149. (defconstant compare-kinds-vec
  150.   (apply #'vector compare-kinds))
  151.  
  152. (defun compare-kind (kind)
  153.   (or (position kind compare-kinds)
  154.       (error "Unknown floating point compare kind: ~S~%Must be one of: ~S"
  155.          kind
  156.          compare-kinds)))
  157.  
  158. (define-argument-type compare-kind
  159.   :type `(member ,@compare-kinds)
  160.   :function compare-kind
  161.   :disassem-printer compare-kinds-vec)
  162.  
  163.  
  164. (defconstant float-operations '(+ - * /))
  165. (defconstant float-operation-names
  166.   ;; this gets used for output only
  167.   #(add sub mul div))
  168.  
  169. (defun float-operation (op)
  170.   (or (position op float-operations)
  171.       (error "Unknown floating point operation: ~S~%Must be one of: ~S"
  172.          op
  173.          float-operations)))
  174.  
  175. (define-argument-type float-operation
  176.   :type `(member ,@float-operations)
  177.   :function float-operation
  178.   :disassem-printer float-operation-names)
  179.  
  180. (define-fixup-type :jump
  181.   :disassem-printer #'(lambda (value stream dstate)
  182.             (let ((addr (ash value 2)))
  183.               (disassem:maybe-note-assembler-routine addr dstate)
  184.               (write addr :base 16 :radix t :stream stream))))
  185. (define-fixup-type :lui :disassem-printer "#x~4,'0X")
  186. (define-fixup-type :addi)
  187.  
  188.  
  189.  
  190. ;;;; Formats.
  191.  
  192. (defconstant special-op #b000000)
  193. (defconstant bcond-op #b0000001)
  194. (defconstant cop0-op #b010000)
  195. (defconstant cop1-op #b010001)
  196. (defconstant cop2-op #b010010)
  197. (defconstant cop3-op #b010011)
  198.  
  199. (defconstant immed-printer
  200.   '(:name :tab rt (:unless (:same-as rt) ", " rs) ", " immediate))
  201.  
  202. ;;; for things that use rt=0 as a nop
  203. (defconstant immed-zero-printer
  204.   '(:name :tab rt (:unless (:constant 0) ", " rs) ", " immediate))
  205.  
  206.  
  207. (define-format (immediate 32
  208.         :disassem-printer immed-printer)
  209.   (op (byte 6 26))
  210.   (rs (byte 5 21) :read t :default-type register)
  211.   (rt (byte 5 16) :write t :default-type register)
  212.   (immediate (byte 16 0) :default-type (signed-byte 16)))
  213.  
  214. (define-format (jump 32
  215.         :disassem-printer '(:name :tab target))
  216.   (op (byte 6 26))
  217.   (target (byte 26 0) :default-type (unsigned-byte 26)))
  218.  
  219. (defconstant reg-printer
  220.   '(:name :tab rd (:unless (:same-as rd) ", " rs) ", " rt))
  221.  
  222. (define-format (register 32 :disassem-printer reg-printer)
  223.   (op (byte 6 26))
  224.   (rs (byte 5 21) :read t :default-type register)
  225.   (rt (byte 5 16) :read t :default-type register)
  226.   (rd (byte 5 11) :write t :default-type register)
  227.   (shamt (byte 5 6) :default 0 :default-type (unsigned-byte 5))
  228.   (funct (byte 6 0)))
  229.  
  230.  
  231. (define-format (break 32
  232.         :disassem-printer
  233.           '(:name :tab code (:unless (:constant 0) subcode)))
  234.   (op (byte 6 26) :default special-op)
  235.   (code (byte 10 16))
  236.   (subcode (byte 10 6) :default 0)
  237.   (funct (byte 6 0) :default #b001101))
  238.  
  239.  
  240. (define-format (coproc-branch 32
  241.         :use (float-status)
  242.         :disassem-printer '(:name :tab offset))
  243.   (op (byte 6 26))
  244.   (funct (byte 10 16))
  245.   (offset (byte 16 0) :default-type (signed-byte 16)))
  246.  
  247. (defconstant float-fmt-printer
  248.   '((:unless :constant funct)
  249.     (:choose (:unless :constant sub-funct) nil)
  250.     "." format))
  251.  
  252. (defconstant float-printer
  253.   `(:name ,@float-fmt-printer
  254.       :tab
  255.       fd
  256.       (:unless (:same-as fd) ", " fs)
  257.       ", " ft))
  258.  
  259. (define-format (float 32 :use (float-status) :clobber (float-status)
  260.         :disassem-printer float-printer)
  261.   (op (byte 6 26) :default #b010001)
  262.   (filler (byte 1 25) :default #b1)
  263.   (format (byte 4 21) :default-type float-format)
  264.   (ft (byte 5 16) :read t :default-type fp-reg)
  265.   (fs (byte 5 11) :read t :default-type fp-reg)
  266.   (fd (byte 5 6) :write t :default-type fp-reg)
  267.   (funct (byte 6 0)))
  268.  
  269. (define-format (float-aux 32 :use (float-status) :clobber (float-status)
  270.               :disassem-printer float-printer)
  271.   (op (byte 6 26) :default #b010001)
  272.   (filler-1 (byte 1 25) :default #b1)
  273.   (format (byte 4 21) :default-type float-format)
  274.   (ft (byte 5 16) :read t :default 0 :default-type fp-reg)
  275.   (fs (byte 5 11) :read t :default-type fp-reg)
  276.   (fd (byte 5 6) :write t :default-type fp-reg)
  277.   (funct (byte 2 4))
  278.   (sub-funct (byte 4 0)))
  279.  
  280.  
  281.  
  282. ;;;; Instructions.
  283.  
  284.  
  285. (defmacro define-math-inst (name r3 imm &optional imm-type function fixup)
  286.   `(define-instruction (,name)
  287.      ,@(when imm
  288.      `((immediate (op :constant ,imm)
  289.               (rt :argument register)
  290.               (rs :same-as rt)
  291.               (immediate :argument (,(case imm-type
  292.                            (:signed 'signed-byte)
  293.                            (:unsigned 'unsigned-byte))
  294.                         16)
  295.                  ,@(when function
  296.                      `(:function ,function))))
  297.        (immediate (op :constant ,imm)
  298.               (rt :argument register)
  299.               (rs :argument register)
  300.               (immediate :argument (,(case imm-type
  301.                            (:signed 'signed-byte)
  302.                            (:unsigned 'unsigned-byte))
  303.                         16)
  304.                  ,@(when function
  305.                      `(:function ,function))))))
  306.      ,@(when (and imm fixup)
  307.      `((immediate (op :constant ,imm)
  308.               (rt :argument register)
  309.               (rs :same-as rt)
  310.               (immediate :argument addi-fixup))
  311.        (immediate (op :constant ,imm)
  312.               (rt :argument register)
  313.               (rs :argument register)
  314.               (immediate :argument addi-fixup))))
  315.      ,@(when r3
  316.      `((register (op :constant special-op)
  317.              (rd :argument register)
  318.              (rs :argument register)
  319.              (rt :argument register)
  320.              (funct :constant ,r3))
  321.        (register (op :constant special-op)
  322.              (rd :argument register)
  323.              (rs :same-as rd)
  324.              (rt :argument register)
  325.              (funct :constant ,r3))))))
  326.  
  327. (define-math-inst add #b100000 #b001000 :signed)
  328. (define-math-inst addu #b100001 #b001001 :signed nil t)
  329. (define-math-inst sub #b100010 #b001000 :signed -)
  330. (define-math-inst subu #b100011 #b001001 :signed -)
  331. (define-math-inst and #b100100 #b001100 :unsigned)
  332. (define-math-inst or #b100101 #b001101 :unsigned)
  333. (define-math-inst xor #b100110 #b001110 :unsigned)
  334. (define-math-inst nor #b100111 #b001111 :unsigned)
  335.  
  336. (define-math-inst slt #b101010 #b001010 :signed)
  337. (define-math-inst sltu #b101011 #b001011 :signed)
  338.  
  339. (defstruct lui-note
  340.   target-reg
  341.   high-bits
  342.   following-addr)
  343.  
  344. (defun look-at-lui-note (chunk inst stream dstate)
  345.   (when stream
  346.     (let ((lui-note (disassem:dstate-get-prop dstate 'lui-note)))
  347.       (when (and lui-note
  348.          (= (disassem:dstate-curpos dstate)
  349.             (lui-note-following-addr lui-note))
  350.          (= (disassem:arg-value 'rt chunk inst)
  351.             (lui-note-target-reg lui-note)))
  352.     (let ((value
  353.            (+ (lui-note-high-bits lui-note)
  354.           (disassem:arg-value 'immediate
  355.                       chunk inst))))
  356.     (or (disassem:maybe-note-assembler-routine value dstate)
  357.         (disassem:note #'(lambda (stream)
  358.                    (format stream "#x~x (~d)"
  359.                        value
  360.                        (disassem:sign-extend value 32)))
  361.                dstate))))))) 
  362.  
  363. (disassem:specialize (or :disassem-control #'look-at-lui-note)
  364.   immediate)
  365. (disassem:specialize (add :disassem-control #'look-at-lui-note)
  366.   immediate)
  367.  
  368. ;;; note: this must be after the above, because the disassem-controls
  369. ;;; are exclusive
  370. (disassem:specialize (add
  371.               :disassem-control
  372.                 #'(lambda (chunk inst stream dstate)
  373.                 (when stream
  374.                   (disassem:maybe-note-nil-indexed-object
  375.                    (disassem:arg-value 'immediate chunk inst)
  376.                    dstate))))
  377.   immediate
  378.   (rs :constant null-offset))
  379.  
  380.  
  381. (define-instruction (beq :pinned t
  382.              :attributes (relative-branch delayed-branch))
  383.   (immediate (op :constant #b000100)
  384.          (rs :argument register)
  385.          (rt :constant 0)
  386.          (immediate :argument relative-label))
  387.   (immediate (op :constant #b000100)
  388.          (rs :argument register)
  389.          (rt :argument register :read t :write nil)
  390.          (immediate :argument relative-label)))
  391.  
  392. (define-instruction (bne :pinned t
  393.              :attributes (relative-branch delayed-branch))
  394.   (immediate (op :constant #b000101)
  395.          (rs :argument register)
  396.          (rt :constant 0)
  397.          (immediate :argument relative-label))
  398.   (immediate (op :constant #b000101)
  399.          (rs :argument register)
  400.          (rt :argument register :read t :write nil)
  401.          (immediate :argument relative-label)))
  402.  
  403. (defconstant cond-branch-printer
  404.   '(:name :tab rs ", " immediate))
  405.  
  406. (define-instruction (blez :pinned t
  407.               :attributes (relative-branch delayed-branch)
  408.               :disassem-printer cond-branch-printer)
  409.   (immediate (op :constant #b000110)
  410.          (rs :argument register)
  411.          (rt :constant 0)
  412.          (immediate :argument relative-label)))
  413.  
  414. (define-instruction (bgtz :pinned t
  415.               :attributes (relative-branch delayed-branch)
  416.               :disassem-printer cond-branch-printer)
  417.   (immediate (op :constant #b000111)
  418.          (rs :argument register)
  419.          (rt :constant 0)
  420.          (immediate :argument relative-label)))
  421.  
  422. (define-instruction (bltz :pinned t
  423.               :attributes (relative-branch delayed-branch)
  424.               :disassem-printer cond-branch-printer)
  425.   (immediate (op :constant bcond-op)
  426.          (rs :argument register)
  427.          (rt :constant #b00000)
  428.          (immediate :argument relative-label)))
  429.  
  430. (define-instruction (bgez :pinned t
  431.               :attributes (relative-branch delayed-branch)
  432.               :disassem-printer cond-branch-printer)
  433.   (immediate (op :constant bcond-op)
  434.          (rs :argument register)
  435.          (rt :constant #b00001)
  436.          (immediate :argument relative-label)))
  437.  
  438. (define-instruction (bltzal :pinned t
  439.                 :attributes (relative-branch delayed-branch)
  440.                 :disassem-printer cond-branch-printer)
  441.   (immediate (op :constant bcond-op)
  442.          (rs :argument register)
  443.          (rt :constant #b01000)
  444.          (immediate :argument relative-label)))
  445.  
  446. (define-instruction (bgezal :pinned t
  447.                 :attributes (relative-branch delayed-branch)
  448.                 :disassem-printer cond-branch-printer)
  449.   (immediate (op :constant bcond-op)
  450.          (rs :argument register)
  451.          (rt :constant #b01001)
  452.          (immediate :argument relative-label)))
  453.  
  454. (define-instruction (bc1f :pinned t
  455.               :attributes (relative-branch delayed-branch))
  456.   (coproc-branch (op :constant cop1-op)
  457.          (funct :constant #x100)
  458.          (offset :argument relative-label)))
  459.  
  460. (define-instruction (bc1t :pinned t
  461.               :attributes (relative-branch delayed-branch))
  462.   (coproc-branch (op :constant cop1-op)
  463.          (funct :constant #x101)
  464.          (offset :argument relative-label)))
  465.  
  466. ;;; ----------------------------------------------------------------
  467.  
  468. (defun snarf-error-junk (sap offset &optional length-only)
  469.   (let* ((length (system:sap-ref-8 sap offset))
  470.      (vector (make-array length :element-type '(unsigned-byte 8))))
  471.     (declare (type system:system-area-pointer sap)
  472.          (type (unsigned-byte 8) length)
  473.          (type (simple-array (unsigned-byte 8) (*)) vector))
  474.     (cond (length-only
  475.        (values 0 (1+ length) nil nil))
  476.       (t
  477.        (kernel:copy-from-system-area sap (* mips:byte-bits (1+ offset))
  478.                      vector (* mips:word-bits
  479.                            mips:vector-data-offset)
  480.                      (* length mips:byte-bits))
  481.        (collect ((sc-offsets)
  482.              (lengths))
  483.          (lengths 1)        ; the length byte
  484.          (let* ((index 0)
  485.             (error-number (c::read-var-integer vector index)))
  486.            (lengths index)
  487.            (loop
  488.          (when (>= index length)
  489.            (return))
  490.          (let ((old-index index))
  491.            (sc-offsets (c::read-var-integer vector index))
  492.            (lengths (- index old-index))))
  493.            (values error-number
  494.                (1+ length)
  495.                (sc-offsets)
  496.                (lengths))))))))
  497.  
  498. (defmacro break-cases (breaknum &body cases)
  499.   (let ((bn-temp (gensym)))
  500.     (collect ((clauses))
  501.       (dolist (case cases)
  502.     (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
  503.       `(let ((,bn-temp ,breaknum))
  504.      (cond ,@(clauses))))))
  505.  
  506. (defun break-control (chunk inst stream dstate)
  507.   (flet ((nt (x) (if stream (disassem:note x dstate))))
  508.     (break-cases (disassem:arg-value 'code chunk inst)
  509.       (vm:error-trap
  510.        (nt "Error trap")
  511.        (disassem:handle-break-args #'snarf-error-junk stream dstate))
  512.       (vm:cerror-trap
  513.        (nt "Cerror trap")
  514.        (disassem:handle-break-args #'snarf-error-junk stream dstate))
  515.       (vm:breakpoint-trap
  516.        (nt "Breakpoint trap"))
  517.       (vm:pending-interrupt-trap
  518.        (nt "Pending interrupt trap"))
  519.       (vm:halt-trap
  520.        (nt "Halt trap"))
  521.       (vm:function-end-breakpoint-trap
  522.        (nt "Function end breakpoint trap"))
  523.     )))
  524.  
  525. (define-instruction (break :pinned t :disassem-control #'break-control)
  526.   (break (code :argument (unsigned-byte 10)))
  527.   (break (code :argument (unsigned-byte 10))
  528.      (subcode :argument (unsigned-byte 10))))
  529.  
  530. ;;; ----------------------------------------------------------------
  531.  
  532. (defconstant divmul-printer '(:name :tab rs ", " rt))
  533.  
  534. (define-instruction (div :clobber (low high) :disassem-printer divmul-printer)
  535.   (register (op :constant special-op)
  536.         (rs :argument register)
  537.         (rt :argument register)
  538.         (rd :constant 0)
  539.         (funct :constant #b011010)))
  540.  
  541. (define-instruction (divu :clobber (low high) :disassem-printer divmul-printer)
  542.   (register (op :constant special-op)
  543.         (rs :argument register)
  544.         (rt :argument register)
  545.         (rd :constant 0)
  546.         (funct :constant #b011011)))
  547.  
  548. (define-instruction (j :pinned t
  549.                :attributes (unconditional-branch delayed-branch)
  550.                :disassem-printer '(:name :tab (:choose rs target)))
  551.   (register (op :constant special-op)
  552.         (rs :argument register)
  553.         (rt :constant 0)
  554.         (rd :constant 0)
  555.         (funct :constant #b001000))
  556.   (jump (op :constant #b000010)
  557.     (target :argument jump-fixup)))
  558.  
  559. (define-instruction (jal :pinned t
  560.              :attributes (delayed-branch assembly-call)
  561.              :disassem-printer
  562.              '(:name :tab
  563.                ;(:unless (:constant 31) rd ", ")
  564.                (:choose rs target)))
  565.   (register (op :constant special-op)
  566.         (rs :argument register)
  567.         (rt :constant 0)
  568.         (rd :constant 31)
  569.         (funct :constant #b001001))
  570.   (register (op :constant special-op)
  571.         (rd :argument register)
  572.         (rs :argument register)
  573.         (rt :constant 0)
  574.         (funct :constant #b001001))
  575.   (jump (op :constant #b000011)
  576.     (target :argument jump-fixup)))
  577.  
  578. (defconstant load-store-printer 
  579.   '(:name :tab
  580.       rt ", "
  581.       rs
  582.       (:unless (:constant 0) "[" immediate "]")))
  583.  
  584. (defmacro define-load/store-instruction (name read-p op
  585.                           &optional (rt-kind 'register))
  586.   `(define-instruction (,name ,@(if read-p
  587.                     '(:use (memory) :attributes (delayed-load))
  588.                     '(:clobber (memory)))
  589.                   :disassem-printer load-store-printer)
  590.      (immediate (op :constant ,op)
  591.         (rt :argument ,rt-kind ,@(unless read-p
  592.                        '(:read t :write nil)))
  593.         (rs :argument register)
  594.         (immediate :argument (signed-byte 16)))
  595.      (immediate (op :constant ,op)
  596.         (rt :argument ,rt-kind ,@(unless read-p
  597.                        '(:read t :write nil)))
  598.         (rs :argument register)
  599.         (immediate :argument addi-fixup))
  600.      (immediate (op :constant ,op)
  601.         (rt :argument ,rt-kind ,@(unless read-p
  602.                        '(:read t :write nil)))
  603.         (rs :argument register)
  604.         (immediate :constant 0))))
  605.  
  606. (define-load/store-instruction lb t #b100000)
  607. (define-load/store-instruction lh t #b100001)
  608. (define-load/store-instruction lwl t #b100010)
  609. (define-load/store-instruction lw t #b100011)
  610. (define-load/store-instruction lbu t #b100100)
  611. (define-load/store-instruction lhu t #b100101)
  612. (define-load/store-instruction lwr t #b100110)
  613. (define-load/store-instruction lwc1 t #o61 fp-reg)
  614. (define-load/store-instruction lwc1-odd t #o61 odd-fp-reg)
  615. (define-load/store-instruction sb nil #b101000)
  616. (define-load/store-instruction sh nil #b101001)
  617. (define-load/store-instruction swl nil #b101010)
  618. (define-load/store-instruction sw nil #b101011)
  619. (define-load/store-instruction swr nil #b101110)
  620. (define-load/store-instruction swc1 nil #o71 fp-reg)
  621. (define-load/store-instruction swc1-odd nil #o71 odd-fp-reg)
  622.  
  623. ;;; ----------------------------------------------------------------
  624. ;;; Disassembler annotation
  625.  
  626. (defun note-niss-ref (chunk inst stream dstate)
  627.   (when stream
  628.     (disassem:maybe-note-nil-indexed-symbol-slot-ref
  629.      (disassem:arg-value 'immediate chunk inst)
  630.      dstate)))
  631.  
  632. (defun note-control-stack-var-ref (chunk inst stream dstate)
  633.   (when stream
  634.     (disassem:maybe-note-single-storage-ref
  635.      (disassem:arg-value 'immediate chunk inst)
  636.      'control-stack
  637.      dstate))
  638.   )
  639.  
  640. (defun note-number-stack-var-ref (chunk inst stream dstate)
  641.   (when stream
  642.     (disassem:maybe-note-single-storage-ref
  643.      (disassem:arg-value 'immediate chunk inst)
  644.      'number-stack
  645.      dstate))
  646.   )
  647.  
  648. (disassem:specialize (lw
  649.               :disassem-control
  650.                 #'(lambda (chunk inst stream dstate)
  651.                 (when stream
  652.                   (disassem:note-code-constant
  653.                    (disassem:arg-value 'immediate chunk inst)
  654.                    dstate))))
  655.   immediate
  656.   (rs :constant code-offset))
  657.  
  658. (disassem:specialize (lw :disassem-control #'note-niss-ref)
  659.   immediate
  660.   (rs :constant null-offset))
  661. (disassem:specialize (lw :disassem-control #'note-control-stack-var-ref)
  662.   immediate
  663.   (rs :constant cfp-offset))
  664. (disassem:specialize (lw :disassem-control #'note-number-stack-var-ref)
  665.   immediate
  666.   (rs :constant nfp-offset))
  667.  
  668. (disassem:specialize (sw :disassem-control #'note-niss-ref)
  669.   immediate
  670.   (rs :constant null-offset))
  671. (disassem:specialize (sw :disassem-control #'note-control-stack-var-ref)
  672.   immediate
  673.   (rs :constant cfp-offset))
  674. (disassem:specialize (sw :disassem-control #'note-number-stack-var-ref)
  675.   immediate
  676.   (rs :constant nfp-offset))
  677.  
  678. ;;; floating point
  679. (disassem:specialize (lwc1 :disassem-control #'note-number-stack-var-ref)
  680.   immediate
  681.   (rs :constant nfp-offset))
  682. (disassem:specialize (swc1 :disassem-control #'note-number-stack-var-ref)
  683.   immediate
  684.   (rs :constant nfp-offset))
  685.  
  686.  
  687. (defun lui-note (chunk inst stream dstate)
  688.   (when stream
  689.     (let ((lui-note (disassem:dstate-get-prop dstate 'lui-note)))
  690.       (when (null lui-note)
  691.     (setf lui-note (make-lui-note)
  692.           (disassem:dstate-get-prop dstate 'lui-note) lui-note))
  693.       (setf (lui-note-target-reg lui-note)
  694.         (disassem:arg-value 'rt chunk inst))
  695.       (setf (lui-note-high-bits lui-note)
  696.         (ash (disassem:arg-value 'immediate chunk inst) 10))
  697.       (setf (lui-note-following-addr lui-note)
  698.         (disassem:dstate-nextpos dstate)))))
  699.  
  700. ;;; ----------------------------------------------------------------
  701.  
  702. (define-instruction (lui :disassem-control #'lui-note)
  703.   (immediate (op :constant #b001111)
  704.          (rs :constant 0)
  705.          (rt :argument register)
  706.          (immediate :argument (or (unsigned-byte 16) (signed-byte 16))))
  707.   (immediate (op :constant #b001111)
  708.          (rs :constant 0)
  709.          (rt :argument register)
  710.          (immediate :argument lui-fixup)))
  711.  
  712.  
  713. (defconstant mvsreg-printer '(:name :tab rd))
  714.  
  715. (define-instruction (mfhi :use (high) :disassem-printer mvsreg-printer)
  716.   (register (op :constant special-op)
  717.         (rd :argument register)
  718.         (rs :constant 0)
  719.         (rt :constant 0)
  720.         (funct :constant #b010000)))
  721.  
  722. (define-instruction (mthi :clobber (high) :disassem-printer mvsreg-printer)
  723.   (register (op :constant special-op)
  724.         (rd :argument register)
  725.         (rs :constant 0)
  726.         (rt :constant 0)
  727.         (funct :constant #b010001)))
  728.  
  729. (define-instruction (mflo :use (low) :disassem-printer mvsreg-printer)
  730.   (register (op :constant special-op)
  731.         (rd :argument register)
  732.         (rs :constant 0)
  733.         (rt :constant 0)
  734.         (funct :constant #b010010)))
  735.  
  736. (define-instruction (mtlo :clobber (low) :disassem-printer mvsreg-printer)
  737.   (register (op :constant special-op)
  738.         (rd :argument register)
  739.         (rs :constant 0)
  740.         (rt :constant 0)
  741.         (funct :constant #b010011)))
  742.  
  743.  
  744. (define-instruction (mult :clobber (low high) :disassem-printer divmul-printer)
  745.   (register (op :constant special-op)
  746.         (rs :argument register)
  747.         (rt :argument register)
  748.         (rd :constant 0)
  749.         (funct :constant #b011000)))
  750.  
  751. (define-instruction (multu :clobber (low high)
  752.                :disassem-printer divmul-printer)
  753.   (register (op :constant special-op)
  754.         (rs :argument register)
  755.         (rt :argument register)
  756.         (rd :constant 0)
  757.         (funct :constant #b011001)))
  758.  
  759. (defconstant shift-printer
  760.   '(:name :tab
  761.       rd
  762.       (:unless (:same-as rd) ", " rt)
  763.       ", " (:cond ((rs :constant 0) shamt)
  764.               (t rs))))
  765.  
  766. (define-instruction (sll :disassem-printer shift-printer)
  767.   (register (op :constant special-op)
  768.         (rd :argument register)
  769.         (rt :argument register)
  770.         (rs :constant 0)
  771.         (shamt :argument (unsigned-byte 5))
  772.         (funct :constant #b000000))
  773.   (register (op :constant special-op)
  774.         (rd :argument register)
  775.         (rt :same-as rd)
  776.         (rs :constant 0)
  777.         (shamt :argument (unsigned-byte 5))
  778.         (funct :constant #b000000))
  779.   (register (op :constant special-op)
  780.         (rd :argument register)
  781.         (rt :argument register)
  782.         (rs :argument register)
  783.         (funct :constant #b000100))
  784.   (register (op :constant special-op)
  785.         (rd :argument register)
  786.         (rt :same-as rd)
  787.         (rs :argument register)
  788.         (funct :constant #b000100)))
  789.  
  790. (define-instruction (sra :disassem-printer shift-printer)
  791.   (register (op :constant special-op)
  792.         (rd :argument register)
  793.         (rt :argument register)
  794.         (rs :constant 0)
  795.         (shamt :argument (unsigned-byte 5))
  796.         (funct :constant #b000011))
  797.   (register (op :constant special-op)
  798.         (rd :argument register)
  799.         (rt :same-as rd)
  800.         (rs :constant 0)
  801.         (shamt :argument (unsigned-byte 5))
  802.         (funct :constant #b000011))
  803.   (register (op :constant special-op)
  804.         (rd :argument register)
  805.         (rt :argument register)
  806.         (rs :argument register)
  807.         (funct :constant #b000111))
  808.   (register (op :constant special-op)
  809.         (rd :argument register)
  810.         (rt :same-as rd)
  811.         (rs :argument register)
  812.         (funct :constant #b000111)))
  813.  
  814. (define-instruction (srl :disassem-printer shift-printer)
  815.   (register (op :constant special-op)
  816.         (rd :argument register)
  817.         (rt :argument register)
  818.         (rs :constant 0)
  819.         (shamt :argument (unsigned-byte 5))
  820.         (funct :constant #b000010))
  821.   (register (op :constant special-op)
  822.         (rd :argument register)
  823.         (rt :same-as rd)
  824.         (rs :constant 0)
  825.         (shamt :argument (unsigned-byte 5))
  826.         (funct :constant #b000010))
  827.   (register (op :constant special-op)
  828.         (rd :argument register)
  829.         (rt :argument register)
  830.         (rs :argument register)
  831.         (funct :constant #b000110))
  832.   (register (op :constant special-op)
  833.         (rd :argument register)
  834.         (rt :same-as rd)
  835.         (rs :argument register)
  836.         (funct :constant #b000110)))
  837.  
  838. (define-instruction (syscall :pinned t :disassem-printer '(:name))
  839.   (register (op :constant special-op)
  840.         (rd :constant 0)
  841.         (rt :constant 0)
  842.         (rs :constant 0)
  843.         (funct :constant #b001100)))
  844.  
  845.  
  846.  
  847. ;;;; Floating point instructions.
  848.  
  849. ;; rs is used as a sub-op code
  850. (defconstant sub-op-printer '(:name :tab rd ", " rt))
  851.  
  852. (macrolet ((frob (name kind)
  853.          `(define-instruction (,name :attributes (delayed-load)
  854.                      :disassem-printer sub-op-printer)
  855.         (register (op :constant #b010001)
  856.               (rs :constant #b00100)
  857.               (rd :argument ,kind)
  858.               (rt :argument register)
  859.               (funct :constant 0)))))
  860.   (frob mtc1 fp-reg)
  861.   (frob mtc1-odd odd-fp-reg))
  862.  
  863. (macrolet ((frob (name kind)
  864.          `(define-instruction (,name :attributes (delayed-load)
  865.                      :disassem-printer sub-op-printer)
  866.         (register (op :constant #b010001)
  867.               (rs :constant #b00000)
  868.               (rt :argument register :read nil :write t)
  869.               (rd :argument ,kind :write nil :read t)
  870.               (funct :constant 0)))))
  871.   (frob mfc1 fp-reg)
  872.   (frob mfc1-odd odd-fp-reg))
  873.  
  874. (define-instruction (cfc1 :use (float-status)
  875.               :attributes (delayed-load)
  876.               :disassem-printer sub-op-printer)
  877.   (register (op :constant #b010001)
  878.         (rs :constant #b00010)
  879.         (rt :argument register :read nil :write t)
  880.         (rd :argument control-register :write nil)
  881.         (funct :constant 0)))
  882.  
  883. (define-instruction (ctc1 :use (float-status)
  884.               :clobber (float-status)
  885.               :attributes (delayed-load)
  886.               :disassem-printer sub-op-printer)
  887.   (register (op :constant #b010001)
  888.         (rs :constant #b00110)
  889.         (rt :argument register)
  890.         (rd :argument control-register :write nil)
  891.         (funct :constant 0)))
  892.  
  893. (define-instruction (float-op
  894.              :disassem-printer
  895.                '('f funct "." format
  896.                 :tab
  897.                 fd
  898.                 (:unless (:same-as fd) ", " fs)
  899.                 ", " ft))
  900.   (float (funct :argument float-operation :mask #b11)
  901.      (format :argument float-format)
  902.      (fd :argument fp-reg)
  903.      (fs :argument fp-reg)
  904.      (ft :argument fp-reg)))
  905.  
  906.  
  907. (defconstant float-unop-printer
  908.   `(:name ,@float-fmt-printer :tab fd (:unless (:same-as fd) ", " fs)))
  909.  
  910. (define-instruction (fabs :disassem-printer float-unop-printer)
  911.   (float (format :argument float-format)
  912.      (ft :constant 0)
  913.      (fd :argument fp-reg)
  914.      (fs :argument fp-reg)
  915.      (funct :constant #b000101))
  916.   (float (format :argument float-format)
  917.      (ft :constant 0)
  918.      (fd :argument fp-reg)
  919.      (fs :same-as fd)
  920.      (funct :constant #b000101)))
  921.  
  922. (define-instruction (fneg :disassem-printer float-unop-printer)
  923.   (float (format :argument float-format)
  924.      (ft :constant 0)
  925.      (fd :argument fp-reg)
  926.      (fs :argument fp-reg)
  927.      (funct :constant #b000111))
  928.   (float (format :argument float-format)
  929.      (ft :constant 0)
  930.      (fd :argument fp-reg)
  931.      (fs :same-as fd)
  932.      (funct :constant #b000111)))
  933.  
  934. (define-instruction (fcvt
  935.              :disassem-printer
  936.                `(:name "." sub-funct "." format
  937.                    :tab
  938.                    fd ", " fs))
  939.   (float-aux (sub-funct :argument float-format)
  940.          (format :argument float-format)
  941.          (fd :argument fp-reg)
  942.          (fs :argument fp-reg)
  943.          (funct :constant #b10)))
  944.  
  945.   
  946. (define-instruction (fcmp
  947.              :disassem-printer
  948.                `(:name "-" sub-funct "." format
  949.                    :tab
  950.                    fs ", " ft))
  951.   (float-aux (sub-funct :argument compare-kind)
  952.          (format :argument float-format)
  953.          (fd :constant 0)
  954.          (fs :argument fp-reg)
  955.          (ft :argument fp-reg)
  956.          (funct :constant #b11)))
  957.  
  958.  
  959. ;;;; Pseudo-instructions
  960.  
  961. (define-instruction (move
  962.              :disassem-printer
  963.              '(:name
  964.                :tab
  965.                (:choose rd fd) ", "
  966.                (:choose rs fs)))
  967.   (register (op :constant special-op)
  968.         (rd :argument register)
  969.         (rs :argument register)
  970.         (rt :constant 0)
  971.         (funct :constant #b100001))
  972.   (float (format :argument float-format)
  973.      (fd :argument fp-reg)
  974.      (fs :argument fp-reg)
  975.      (ft :constant 0)
  976.      (funct :constant #b000110)))
  977.  
  978. (define-pseudo-instruction li 64 (reg value)
  979.   (etypecase value
  980.     ((unsigned-byte 16)
  981.      (inst or reg zero-tn value))
  982.     ((signed-byte 16)
  983.      (inst addu reg zero-tn value))
  984.     ((or (signed-byte 32) (unsigned-byte 32))
  985.      (inst lui reg (ldb (byte 16 16) value))
  986.      (let ((low (ldb (byte 16 0) value)))
  987.        (unless (zerop low)
  988.      (inst or reg low))))
  989.     (fixup
  990.      (inst lui reg value)
  991.      (inst addu reg value))))
  992.  
  993. (define-instruction (b :pinned t
  994.                :attributes (relative-branch unconditional-branch
  995.                             delayed-branch)
  996.                :disassem-printer '(:name :tab immediate))
  997.   (immediate (op :constant #b000100)
  998.          (rs :constant 0)
  999.          (rt :constant 0)
  1000.          (immediate :argument relative-label)))
  1001.  
  1002. (define-instruction (nop :attributes (nop)
  1003.              :disassem-printer '(:name))
  1004.   (register (op :constant 0)
  1005.         (rd :constant 0)
  1006.         (rt :constant 0)
  1007.         (rs :constant 0)
  1008.         (funct :constant 0)))
  1009.  
  1010. (define-format (word-format 32 :pinned t)
  1011.   (data (byte 32 0)))
  1012. (define-instruction (word :cost 0)
  1013.   (word-format (data :argument (or (unsigned-byte 32) (signed-byte 32)))))
  1014.  
  1015. (define-format (short-format 16 :pinned t)
  1016.   (data (byte 16 0)))
  1017. (define-instruction (short :cost 0)
  1018.   (short-format (data :argument (or (unsigned-byte 16) (signed-byte 16)))))
  1019.  
  1020. (define-format (byte-format 8 :pinned t)
  1021.   (data (byte 8 0)))
  1022. (define-instruction (byte :cost 0)
  1023.   (byte-format (data :argument (or (unsigned-byte 8) (signed-byte 8)))))
  1024.  
  1025.  
  1026.  
  1027. ;;;; Function and LRA Headers emitters and calculation stuff.
  1028.  
  1029. (define-format (entry-point 0 :pinned t))
  1030. (define-instruction (entry-point)
  1031.   (entry-point))
  1032.  
  1033. (defun header-data (ignore)
  1034.   (declare (ignore ignore))
  1035.   (ash (+ *current-position* (component-header-length)) (- vm:word-shift)))
  1036.  
  1037. (define-format (header-object 32 :pinned t)
  1038.   (type (byte 8 0))
  1039.   (data (byte 24 8) :default 0 :function header-data))
  1040.  
  1041. (define-instruction (function-header-word)
  1042.   (header-object (type :constant vm:function-header-type)))
  1043.  
  1044. (define-instruction (lra-header-word)
  1045.   (header-object (type :constant vm:return-pc-header-type)))
  1046.  
  1047.  
  1048. (defmacro define-compute-instruction (name calculation)
  1049.   (let ((addui (symbolicate name "-ADDUI"))
  1050.     (lui (symbolicate name "-LUI"))
  1051.     (ori (symbolicate name "-ORI")))
  1052.     `(progn
  1053.        (defun ,name (label)
  1054.      (let ((result ,calculation))
  1055.        (assert (typep result '(signed-byte 16)))
  1056.        result))
  1057.        (define-instruction (,addui)
  1058.      (immediate (op :constant #b001001)
  1059.             (rt :argument register)
  1060.             (rs :argument register)
  1061.             (immediate :argument label
  1062.                    :function ,name)))
  1063.        (define-instruction (,lui)
  1064.      (immediate (op :constant #b001111)
  1065.             (rs :constant 0)
  1066.             (rt :argument register :read t)
  1067.             (immediate :argument label
  1068.                    :function (lambda (label)
  1069.                        (ash ,calculation -16)))))
  1070.        (define-instruction (,ori)
  1071.      (immediate (op :constant #b001101)
  1072.             (rt :argument register)
  1073.             (rs :same-as rt)
  1074.             (immediate :argument label
  1075.  
  1076.                    :function (lambda (label)
  1077.                        (logand ,calculation #xffff)))))
  1078.        (define-pseudo-instruction ,name 96 (dst src label temp)
  1079.      (cond ((typep ,calculation '(signed-byte 16))
  1080.         (inst ,addui dst src label))
  1081.            (t
  1082.         (inst ,lui temp label)
  1083.         (inst ,ori temp label)
  1084.         (inst addu dst src temp)))))))
  1085.  
  1086.  
  1087. ;; code = fn - header - label-offset + other-pointer-tag
  1088. (define-compute-instruction compute-code-from-fn
  1089.                 (- vm:other-pointer-type
  1090.                    (label-position label)
  1091.                    (component-header-length)))
  1092.  
  1093. ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
  1094. (define-compute-instruction compute-code-from-lra
  1095.                 (- (+ (label-position label)
  1096.                   (component-header-length))))
  1097.  
  1098. ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
  1099. (define-compute-instruction compute-lra-from-code
  1100.                 (+ (label-position label)
  1101.                    (component-header-length)))
  1102.